home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / unix / tclXtTest.c < prev   
Encoding:
C/C++ Source or Header  |  1997-08-15  |  2.9 KB  |  114 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclXtTest.c --
  3.  *
  4.  *    Contains commands for Xt notifier specific tests on Unix.
  5.  *
  6.  * Copyright (c) 1997 by Sun Microsystems, Inc.
  7.  *
  8.  * See the file "license.terms" for information on usage and redistribution
  9.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10.  *
  11.  * SCCS: @(#) tclXtTest.c 1.1 97/03/24 14:30:42
  12.  */
  13.  
  14. #include <X11/Intrinsic.h>
  15. #include "tcl.h"
  16.  
  17. static int    TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
  18.             Tcl_Interp *interp, int argc, char **argv));
  19.  
  20. /*
  21.  *----------------------------------------------------------------------
  22.  *
  23.  * Tclxttest_Init --
  24.  *
  25.  *    This procedure performs application-specific initialization.
  26.  *    Most applications, especially those that incorporate additional
  27.  *    packages, will have their own version of this procedure.
  28.  *
  29.  * Results:
  30.  *    Returns a standard Tcl completion code, and leaves an error
  31.  *    message in interp->result if an error occurs.
  32.  *
  33.  * Side effects:
  34.  *    Depends on the startup script.
  35.  *
  36.  *----------------------------------------------------------------------
  37.  */
  38.  
  39. int
  40. Tclxttest_Init(interp)
  41.     Tcl_Interp *interp;        /* Interpreter for application. */
  42. {
  43.     Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
  44.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  45.     return TCL_OK;
  46. }
  47.  
  48. /*
  49.  *----------------------------------------------------------------------
  50.  *
  51.  * TesteventloopCmd --
  52.  *
  53.  *    This procedure implements the "testeventloop" command. It is
  54.  *    used to test the Tcl notifier from an "external" event loop
  55.  *    (i.e. not Tcl_DoOneEvent()).
  56.  *
  57.  * Results:
  58.  *    A standard Tcl result.
  59.  *
  60.  * Side effects:
  61.  *    None.
  62.  *
  63.  *----------------------------------------------------------------------
  64.  */
  65.  
  66. static int
  67. TesteventloopCmd(clientData, interp, argc, argv)
  68.     ClientData clientData;        /* Not used. */
  69.     Tcl_Interp *interp;            /* Current interpreter. */
  70.     int argc;                /* Number of arguments. */
  71.     char **argv;            /* Argument strings. */
  72. {
  73.     static int *framePtr = NULL; /* Pointer to integer on stack frame of
  74.                   * innermost invocation of the "wait"
  75.                   * subcommand. */
  76.  
  77.    if (argc < 2) {
  78.     Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  79.                 " option ... \"", (char *) NULL);
  80.         return TCL_ERROR;
  81.     }
  82.     if (strcmp(argv[1], "done") == 0) {
  83.     *framePtr = 1;
  84.     } else if (strcmp(argv[1], "wait") == 0) {
  85.     int *oldFramePtr;
  86.     int done;
  87.     int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
  88.  
  89.     /*
  90.      * Save the old stack frame pointer and set up the current frame.
  91.      */
  92.  
  93.     oldFramePtr = framePtr;
  94.     framePtr = &done;
  95.  
  96.     /*
  97.      * Enter an Xt event loop until the flag changes.
  98.      * Note that we do not explicitly call Tcl_ServiceEvent().
  99.      */
  100.  
  101.     done = 0;
  102.     while (!done) {
  103.         XtProcessEvent(XtIMAll);
  104.     }
  105.     (void) Tcl_SetServiceMode(oldMode);
  106.     framePtr = oldFramePtr;
  107.     } else {
  108.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  109.         "\": must be done or wait", (char *) NULL);
  110.     return TCL_ERROR;
  111.     }
  112.     return TCL_OK;
  113. }
  114.